perm filename IO[CRE,BGB]3 blob
sn#038332 filedate 1973-04-26 generic text, type T, neo UTF8
00100 TITLE IO - INPUT OUTPUT SUBROUTINES - BGB - 16 APRIL 1973.
00200
00300 EXTERN REMAIN,BLKCNT,FTVHIS,FTVSIX
00400 EXTERN VCUT,TVBUF,HISTO,AVAIL,OLD44,FILM,FLGBGB
00500 EXTERN HEADER,HISTOG,CHR
00600 EXTERN DPYBUF,QBLK,DPYIMG
00700 EXTERN RELLOC,SHRINK,SKY
00800
00900 SUBR(GETFIL)------------------------------------------------------
01000 BEGIN GETFIL;SETUP FILE SPEC FROM TTY LINE - BGB - 10 DEC 72.
01100 DZM FILNAM↔DZM EXTION↔DZM EXTION+1↔DZM PPPN
01200 OUTSTR[ASCIZ/ FILE = /]
01300 LAC 1,[POINT 6,FILNAM,-1]↔LACI 2,6
01400 INCHWL↔CAIN 15↔GO[INCHWL↔POP2J]↔AOSA(P)
01500 L: INCHWL↔CAIL"a"↔SUBI 40
01600 CAIN"."↔GO[LAC 1,[POINT 6,EXTION,-1]↔LACI 2,3↔GO L]
01700 CAIN"["↔GO[LAC 1,[POINT 6,PPPN,-1] ↔LACI 2,3↔GO L]
01800 CAIN","↔GO[LAC 1,[POINT 6,PPPN,17] ↔LACI 2,3↔GO L]
01900 CAIN"]"↔GO L
02000 CAIN 15↔GO EOL ;END OF THE LINE.
02100 CAIN 12↔GO EOL
02200 CAIG" "↔GO L ;IGNORE GARBAGE.
02300 SOJL 2,L↔SUBI 40↔IDPB 1↔GO L
02400
02500 EOL: INCHWL
02600 CAR PPPN
02700 TRNN 77↔LSH -6↔TRNN 77↔LSH -6 ;RIGHT ADJUST PROJECT.
02800 DIP PPPN
02900 CDR PPPN
03000 TRNN 77↔LSH -6↔TRNN 77↔LSH -6 ;RIGHT ADJUST PROGRAMMER.
03100 DAP PPPN
03200 SKIPN 1,EXTION↔LAC 1,ARG2↔DAC 1,EXTION ;DEFAULT EXTENSION.
03300 SKIPN FLGBGB↔POP2J
03400 SKIPN 1,PPPN↔LAC 1,ARG1↔DAC 1,PPPN ;DEFAULT PROJECT.
03500 POP2J
03600 BEND;12/10/72------------------------------------------------------
03700
03800 FILNAM: 0 ;FILE NAME.
03900 EXTION: 0 ;EXTENSION.
04000 0
04100 PPPN: 0 ;PROJECT-PROGRAMMER & FILESIZE -WC SWAPPED.
04200
00100 SUBR(FILNUM)SERIAL. ;SETUP FILE-SERIAL-NUMBER-NAME.
00200 BEGIN FILNUM;------------------------------------------------------
00300 EXTERN FNAME6
00400 LAC 10,FNAME6↔LAC 1,[POINT 6,10,-1] ;FILM NAME SIXBIT.
00500 LAC 0,1↔ILDB 2,1↔SKIPE 2↔GO .-3 ;SCAN FOR 00.
00600
00700 ;CONVERT SERIAL NUMBER TO SIXBIT DECIMAL NUMERAL.
00800 LACM 1,ARG1↔DAC 1,2↔DAC 1,3↔DAC 1,4↔DAC 1,5
00900 CAIL 1,=10000↔GO L5
01000 CAIL 1,=1000↔GO L4
01100 CAIL 1,=100↔GO L3
01200 CAIL 1,=10↔GO L2
01300 ↔GO L1
01400
01500 L5: IDIVI 1,=10000↔ADDI 1,20↔IDPB 1,0
01600 L4: IDIVI 2,=1000 ↔ADDI 2,20↔IDPB 2,0
01700 L3: IDIVI 3,=100 ↔ADDI 3,20↔IDPB 3,0
01800 L2: IDIVI 4,=10 ↔ADDI 4,20↔IDPB 4,0
01900 L1: ADDI 5,20↔IDPB 5,0
02000 DAC 10,FILNAM
02100
02200 ;TMP EXTENSION AND PPPN.
02300 LAC[SIXBIT/TMP/]↔DAC EXTION
02400 DZM EXTION+1
02500 DZM↔SKIPE FLGBGB↔LAC[SIXBIT/DATBGB/]↔DAC PPPN
02600 POP1J
02700
02800 BEND FILNUM; BGB 19 APRIL 1973 ------------------------------------
00100 SUBR(TVDSKI)SERIAL INPUT TV PICTURE FROM DISK FILE.
00200
00300 COMMENT/ Serial -1 asks user for file name. Serial ≥0 attempts
00400 film image XXXX00.TMP input. TVDSKI returns TRUE -1 if image
00500 found or FALSE 0 if image not found./
00600
00700 BEGIN TVDSKI;-----------------------------------------------------
00800
00900 SKIPL 1,ARG1↔GO[CALL(FILNUM,1)↔GO L1]
01000 L0: CALL(GETFIL,[SIXBIT/TMP/],[SIXBIT/DATBGB/])
01100 FALSE: GO[DZM 1↔POP1J] ;RETURN FALSE - NO PICTURE.
01200 L1: INIT 1,17↔SIXBIT/DSK/↔0↔HALT
01300 LOOKUP 1,FILNAM↔GO[SKIPGE ARG1↔GO L0↔GO FALSE]
01400
01500 MOVS PPPN↔MOVMS ;GET FILE SIZE.
01600 CAIN 24400↔GO L2
01700 SUBI 200↔DACN
01800 DIP DUMP2+1
01900 IN 1,DUMP2↔JFCL ;NON-STANDARD SIZE.
02000 CALL(TVPACK)
02100 GO L4
02200
02300 L2: IN 1,DUMP1↔JFCL ;216 x 288 STANDARD SIZE.
02400 L4: OUTSTR[ASCIZ" EOF.
02500 "]↔ RELEASE 1,↔SETO 1,↔POP1J ;RETURN TRUE.
02600
02700 DUMP1: IOWD 200,HEADER
02800 IOWD 24200,TVBUF↔0
02900 DUMP2: IOWD 200,HEADER
03000 IOWD 24200,SKY↔0
03100
03200 BEND TVDSKI; BGB 6 DECEMBER 1972 ---------------------------------
00100 SUBR(TVPACK). PACK TVBUF WITH PICTURE FROM SKY ARRAY.
00200 COMMENT/ Take a non-standard size picture from the SKY array and pack
00300 it into the TVBUF. TVPACK loops are for R ← 0 to 215 and for C ← 0 to
00400 287; at each target pixel a check is made to see if there is a source
00500 pixel to be moved./
00600 BEGIN TVPACK;-----------------------------------------------------
00700
00800 ACCUMULATORS{B,R1,C1,R2,C2,Q0,Q1,Q2}
00900
01000 ;READ TV FILE HEADER & MAKE SURE THAT IT IS REASONIBLE.
01100 SETO↔CAME HEADER↔GO[OUTSTR[ASCIZ/ UNKNOWN, TV FILE FORMAT.
01200 /]↔POP0J]
01300 LAC HEADER+1↔DAC BYTSIZ#
01400 LAC HEADER+2↔DAC WWIDTH#
01500 LAC HEADER+4↔SUB HEADER+3↔AOS↔DAC MROWS#↔LSH -1↔DAC HALFM#
01600 LAC HEADER+6↔SUB HEADER+5↔AOS↔DAC NCOLS#↔LSH -1↔DAC HALFN#
01700
01800 LAC R2,HALFM↔SUBI R2,=108
01900 LAC Q0,R2↔IMUL Q0,WWIDTH
02000 ADDI Q0,SKY↔CDR 0,HEADER+7↔SUBI 0,200↔ADD Q0,0
02100 LAC Q2,[POINT 6,TVBUF,-1]
02200 DZM R1
02300 L0: DZM C1↔LAC C2,HALFN↔SUBI C2,=144
02400 L1: DZM B
02500 SKIPL R2↔CAML R2,MROWS↔GO L2
02600 SKIPL C2↔CAML C2,NCOLS↔GO L2
02700 TLNN Q0,-1↔CALL(L3)
02800 ILDB B,Q1
02900 LSH B,0
03000 L2: IDPB B,Q2
03100 AOS C2↔AOS C1↔CAIE C1,=288↔GO L1
03200 ADD Q0,WWIDTH↔LAC Q1,Q0
03300 AOS R2↔AOS R1↔CAIE R1,=216↔GO L0
03400 POP0J
03500
03600 ;COMPUTE SOURCE COLUMN BYTE POINTER, ONCE PER PICTURE.
03700 L3: LAC 0,C2↔IDIV 0,BYTSIZ↔ADD Q0,0 ;WORD.
03800 IMUL 1,BYTSIZ↔LACI 0,=36↔SUB 0,1 ;P-BITS.
03900 LSH 0,6↔IOR 0,BYTSIZ↔ROT 0,-=12 ;S-BITS.
04000 IOR Q0,0↔LAC Q1,Q0
04100 LACI 6↔SUB BYTSIZ↔DAP L2-1
04200 POP0J
04300
04400 BEND TVPACK; BGB 18 APRIL 1973 -----------------------------------
00100 SUBR(TVDSKO) INPUT TV PICTURE FROM A DISK FILE.
00200 BEGIN TVDSKO;-----------------------------------------------------
00300
00400 CALL(GETFIL,[SIXBIT/TMP/],[SIXBIT/DATBGB/])↔POP0J
00500 INIT 1,17↔SIXBIT/DSK/↔0↔HALT
00600 ENTER 1,FILNAM↔GO[OUTSTR[ASCIZ/ ENTER FAILED.
00700 /]↔GO .+4]
00800 LAC[XWD HEADER,HEADER+1]↔DZM HEADER↔BLT HEADER+177
00900 LAC[XWD HEAD1,HEADER]↔BLT HEADER+7
01000 OUT 1,DUMARG↔JFCL
01100 OUTSTR[ASCIZ" EOF.
01200 "]↔ RELEASE 1,↔POP0J
01300 HEAD1: -1
01400 6 ; BITS PER BYTE.
01500 =48 ;WORDS PER LINE.
01600 =20 ;FIRST AND LAST ROW.
01700 =235
01800 =28
01900 =315 ;FIRST AND LAST COL.
02000 XWD -=10368,200
02100 DUMARG: IOWD 24400,HEADER↔0
02200 BEND TVDSKO; BGB 6 DECEMBER 1973 ---------------------------------
00100
00200 SUBR(PLOTO)-------------------------------------------------------
00300 BEGIN PLOTO;DISPLAY BUFFER TO DISK FILE - BGB 10 DEC 1972.
00400 CALL(GETFIL,[SIXBIT/PLT/],[0])↔POP0J
00500 LAC 1,DPYBUF↔LACN(1)1↔SUBI 2
00600 CDR 2,(1)↔DZM 1(2)
00700 MOVS↔LAPI -1(1)↔DAC DUMLST
00800 INIT 1,17↔SIXBIT/DSK/↔0↔HALT
00900 ENTER 1,FILNAM↔GO .+4
01000 OUT 1,DUMLST↔JFCL
01100 OUTSTR[ASCIZ" EOF.
01200 "]↔ RELEASE 1,↔POP0J
01300 DUMLST: 0↔0
01400 BEND;12/10/72------------------------------------------------------
00100 SUBR(TVXGP) VIDEO BUFFER TO XEROX GRAPHICS PRINTER.
00200 BEGIN TVXGP;------------------------------------------------------
00300 ACCUMULATORS{S2,S3,I,J,K,Q,P1,P2}
00400 COMMENT/ One to sixteen expansion: (216*4=864) by (288*4=1152).
00500 or 32 words per line. Buffer size (864 lines)*33+1= 28513 words./
00600
00700 ;EXPAND CORE FOR XGP BUFFER & CLEAR THE BUFFER.
00800 LAC 44↔DAC SAV44#↔AOS↔DAC XBUF#↔ADDI =28513+10↔CORE↔GO L5
00900 CDR 1,XBUF↔DZM(1)↔DIP 1,1↔AOS 1↔CDR 2,44↔BLT 1,(2)
01000
01100 ;PUT CONTROL WORDS IN THE 864 ROWS OF THE XGP IMAGE.
01200 LAC 1,XBUF
01300 SLACI %↔DAC(1)↔AOS 1 ;CUT PAPER.
01400 SLACI =200⊗6↔DAC(1)↔AOS 1 ;SPACE DOWN 100 LINES.
01500 LAC[1B11+=192B23+=32]↔LACI 2,=864 ;864 ROWS OF 32 WORDS.
01600 DAC(1)↔ADDI 1,=33↔SOJG 2,.-2
01700 LAC[5770B11]↔DAC(1)↔AOS 1 ;SPACE AFTER PICTURE.
01800 SLACI %↔DAC(1) ;CUT PAPER.
01900
02000 ;PACK VIDEO BYTES INTO XGP 4 BY 4 BIT ARRAYS.
02100 LAC P1,[POINT 6,TVBUF,-1]
02200 LAC P2,XBUF↔ADDI P2,3 ;BUFFER POINTER.
02300 LACI I,=216
02400 L1: LACI J,=32
02500 L2: SETZB 0,1↔SETZB 2,3↔LACI K,=9
02600 L3: ILDB Q,P1↔TRZ Q,3↔ROTC 0,4↔ROTC 2,4
02700 IOR 0,HTT+0(Q)↔IOR 1,HTT+1(Q)
02800 IOR 2,HTT+2(Q)↔IOR 3,HTT+3(Q)
02900 SOJG K,L3
03000 DAC 0,=00(P2)↔DAC 1,=33(P2)
03100 DAC 2,=66(P2)↔DAC 3,=99(P2)
03200 AOS P2↔SOJG J,L2
03300 ADDI P2,=100↔SOJG I,L1
03400
03500 ;GRAB THE DEVICE.
03600 L4: INIT 1,17↔SIXBIT/XGP/↔0↔GO[OUTSTR[ASCIZ/XGP INIT FAILED.
03700 /]↔ POP0J]↔SETZ↔SEGNUM↔DAC SAVSEG#↔DETSEG
03800 SLACI -=28516↔LAP XBUF↔SOS↔DAC DUMARG
03900 OUT 1,DUMARG↔RELEASE 1,↔LAC SAV44↔CORE
04000 L5: OUTSTR[ASCIZ/ XGP CORE UUO FAILED.
04100 /]↔ CRLF↔LAC SAVSEG↔ATTSEG↔JFCL↔POP0J
04200 ;HALF TONE TABLE.
04300 HTT: 6↔7↔7↔6↔ 6↔6↔7↔6↔ 6↔6↔6↔6↔ 6↔6↔6↔6
04400 6↔6↔6↔4↔ 4↔6↔6↔4↔ 4↔6↔6↔4↔ 4↔4↔6↔4
04500 4↔4↔4↔4↔ 4↔4↔4↔4↔ 0↔4↔4↔4↔ 4↔4↔4↔0
04600 0↔4↔4↔0↔ 0↔0↔4↔0↔ 0↔0↔4↔0↔ 0↔0↔0↔0
04700 DUMARG:0↔0
04800 BEND;1/19/73-------------------------------------------------------
00100 SUBR(CREOUT) OUTPUT CONTOURS, REGION, EDGE FILE.
00200 BEGIN CREOUT;-----------------------------------------------------
00600 CALL(SHRINK)
00700 CALL(GETFIL,[SIXBIT/CRE/],[0])↔POP0J
00800 LACN FILM
00900 CALL(RELLOC,0)
01000
01100 ;SETUP DUMP OUT ARGUMENT IOWD.
01200 LAC FILM↔SUB@AVAIL
01300 LACM 1,0↔MOVSS
01400 LAP OLD44↔DAC OUTARG
01500 LAC@FILM↔DAC TMP#↔DAC 1,@FILM ;FILE SIZE IN WORDS.
01600
01700 ;FILE OUTPUT RITUAL.
01800 LAC@AVAIL↔SUB FILM↔DAC@AVAIL
01900 INIT 1,17↔SIXBIT/DSK/↔0↔HALT
02000 ENTER 1,FILNAM
02100 GO[OUTSTR[ASCIZ/ ENTER FAILED.
02200 /]↔GO .+4]
02300 OUT 1,OUTARG↔JFCL
02400 OUTSTR[ASCIZ" EOF.
02500 "]↔ RELEASE 1,
02600 DZM FILNAM↔SETZ EXTION↔DZM EXTION+1↔DZM PPPN
02700 CALL(RELLOC,FILM)
02800 LAC TMP↔DAC@FILM
02900 LAC@AVAIL↔ADD FILM↔DAC@AVAIL
03000 POP0J
03100 OUTARG: 0↔0
03200 BEND CREOUT; BGB 6 DECEMBER 1972 ---------------------------------
00100 SUBR(CREIN) CONTOUR,REGION,EDGE FILE FORMAT INPUT.
00200 BEGIN CREIN;------------------------------------------------------
00400
00500 CALL(GETFIL,[SIXBIT/CRE/],[0])↔POP0J
00600 INIT 1,17↔SIXBIT/DSK/↔0↔HALT
00700 LOOKUP 1,FILNAM↔GO[RELEASE 1,↔GO CREIN]
00800
00900 DZM QBLK
01000 LAC PPPN↔LAP FILM↔SOS↔DAC INARG ;IOWD
01100
01200 MOVS PPPN↔MOVMS↔ADD FILM
01300 IORI 1777↔CAMG 44↔GO L1
01400 CALLI 11↔HALT
01500 LAC 44↔AOS↔SUB FILM
01550 DIVI 7↔DAC 1,REMAINDER
01600 L1: IN 1,INARG
01700 OUTSTR[ASCIZ" EOF.
01800 "]↔ RELEASE 1,
01900
02000 CDR@AVAIL↔ADD FILM↔DAC@AVAIL↔DZM@
02100 DIP↔AOS↔LAC 1,44↔BLT(1) ;CLEAR EMPTY AREA.
02200 CALL(RELLOC,FILM)
02300
02400 ;RESET AVAIL LIST.
02500 LAC 1,@AVAIL↔LAC 2,44
02600 LIPI 1,NODSIZ(1)↔GO L6
02700 L5: HLRZM 1,(1)↔ADD 1,[XWD NODSIZ,NODSIZ]
02800 L6: CAILE 2,NODSIZ+NODSIZ-1(1)↔GO L5
02900 SUBI 2,NODSIZ-1(1)↔DAC 2,REMAINDER
03000 POP0J
03100 INARG: 0↔0
03200 BEND CREIN; BGB 28 JANUARY 1973 ----------------------------------
00100 ;TVIN4. FOUR BIT TELEVISION INPUT.
00200 SUBR(TVIN4)------------------------------------------------------
00300 BEGIN TVIN4
00400 LAC 44↔DAC TMP44#↔AOS↔DAP TVPTR
00500 ADDI=6912↔CORE↔POP0J
00600 L0: INIT 17,17↔SIXBIT/TV/↔0
00700 GO[OUTSTR[ASCIZ"CAN'T INIT TV."]↔INCHRW↔GO .-3]
00800 DZM TVERR↔INPUT 17,TVPTR↔RELEASE 17,
00900
01000 ;REPORT ON THE ERROR BITS AND RETAKE IF NECESSARY;
01100 LAC 1,TVERR
01200 TRNE 1,100000↔OUTSTR[ASCIZ/TV PARITY ERROR.
01300 /]↔ TRNE 1,000040↔OUTSTR[ASCIZ/TV DATA MISS.
01400 /]↔ TRNE 1,000020↔OUTSTR[ASCIZ/TV NON EX MEM.
01500 /]↔ TRNE 1,100060↔JRST L0
01600 TIMER↔DAC TVTIME#
01700 DATE↔DAC TVDATE#
01800 OUTSTR[ASCIZ/AKEN./]
01900 LAC[XWD HISTO,HISTO+1] ;CLEAR THE HISTOGRAM.
02000 DZM HISTO↔BLT HISTO+77
02100
02200 ;CONVERT FROM GREY CODE TO GRAY CODE.
02300 LAC 16,[XWD L,0]↔BLT 16,12
02400 LAP TVPTR↔GO 4
02500
02600 L: POINT 4,0,-1↔ FROM←←0
02700 POINT 6,TVBUF,-1↔ TO←←1
02800 =62208 ↔ CNT←←2
02900 0 ↔ BYT←←3
03000 ILDB BYT,FROM ;4
03100 LAC BYT,GRAY(BYT) ;3
03200 LSH BYT,2 ;6
03300 AOS HISTO(BYT) ;7
03400 IDPB BYT,TO ;8
03500 SOJG CNT,4 ;9
03600 GO .+1 ;12
03700 LAC TMP44↔CORE↔HALT↔POP0J
03800
03900 BEND TVIN4; BGB 14 DECEMBER 1972 ---------------------------------
04000
04100 TVPTR: XWD -=6912,0 ↔ INTERN TVPTR
04200 TVCLIP: 701002 ;BCLIP=7 TCLIP=0 CAM=1.
04300 INTERN TVCLIP
04400 TVYXW: BYTE(9)50,34,40
04500 TVERR: 0
04600 GRAY: OCT 12,13,11,10,15,14,16,17,5,4,6,7,2,3,1,0
00100 SUBR(TVIN6). SIX BIT TELEVISION INPUT.
00200 BEGIN TVIN6;-----------------------------------------------------
00300 LAC 44↔DAC TMP44#↔AOS↔DAP TVPTR
00400 ADDI=6912*4↔CORE↔POP0J
00500 L0: INIT 17,17↔SIXBIT/TV/↔0
00600 GO[OUTSTR[ASCIZ"CAN'T INIT TV."]↔INCHRW↔GO .-3]
00700 DZM TVERR6#↔PUSH P,TVCLIP
00800
00900 LACI 76↔DPB[POINT 6,TVCLIP,23] ;TAKE CLIPS 76.
01000 LAC TVPTR↔LIPI 440400↔DAC P1#
01100 L1: DZM TVERR↔INPUT 17,TVPTR↔LAC TVERR
01200 IORM TVERR6↔TRNE 100060↔GO L1
01300
01400 LACI 54↔DPB[POINT 6,TVCLIP,23] ;TAKE CLIPS 54.
01500 LACI =6912↔ADDB TVPTR↔LIPI 440400↔DAC P2#
01600 L2: DZM TVERR↔INPUT 17,TVPTR↔LAC TVERR
01700 IORM TVERR6↔TRNE 100060↔GO L2
01800
01900 LACI 32↔DPB[POINT 6,TVCLIP,23] ;TAKE CLIPS 32.
02000 LACI =6912↔ADDB TVPTR↔LIPI 440400↔DAC P3#
02100 L3: DZM TVERR↔INPUT 17,TVPTR↔LAC TVERR
02200 IORM TVERR6↔TRNE 100060↔GO L3
02300
02400 LACI 10↔DPB[POINT 6,TVCLIP,23] ;TAKE CLIPS 10.
02500 LACI =6912↔ADDB TVPTR↔LIPI 440400↔DAC P4#
02600 L4: DZM TVERR↔INPUT 17,TVPTR↔LAC TVERR
02700 IORM TVERR6↔TRNE 100060↔GO L4
02800 POP P,TVCLIP↔RELEASE 17,
02900
03000 ;REPORT ON THE ERROR BITS.
03100 LAC 1,TVERR6
03200 TRNE 1,100000↔OUTSTR[ASCIZ/TV PARITY ERROR.
03300 /]↔ TRNE 1,40 ↔OUTSTR[ASCIZ/TV DATA MISS.
03400 /]↔ TRNE 1,20 ↔OUTSTR[ASCIZ/TV NON EX MEM.
03500 /]↔ TIMER↔DAC TVTIME#
03600 DATE↔DAC TVDATE#
03700 LAC[XWD HISTO,HISTO+1]↔DZM HISTO↔BLT HISTO+77
03800 OUTSTR[ASCIZ/AKEN./]
03900 ;CONVERT FROM GREY CODE TO GRAY CODE.
04000 LAC[POINT 6,TVBUF,-1]↔DAC P5#
04100 LAC[XWD L,3]↔BLT 16↔LACI =62208↔GO 3
04200
04300 ;SIX BIT AC-LOOP.
04400 L: ILDB 1,P1↔LAC 2,GRAY(1)
04500 ILDB 1,P2↔ADD 2,GRAY(1)
04600 ILDB 1,P3↔ADD 2,GRAY(1)
04700 ILDB 1,P4↔ADD 2,GRAY(1)
04800 IDPB 2,P5↔AOS HISTO(2)
04900 SOJG 0,3↔GO .+1
05000 LAC TMP44↔CORE↔HALT↔POP0J
05100 BEND TVIN6; BGB 14 DECEMBER 1972 ---------------------------------
00100 ;REALIN - REAL NUMBER INPUT FROM TTY.
00200 SUBR(REALIN)------------------------------------------------------
00300 BEGIN REALIN
00400 ;AC-0 INTEGER ACCUMULATION. AC-0 RETURNS REAL NUMBER.
00500 ;AC-1 CHARACTER. AC-1 RETURNS BREAK CHARACTER.
00600 ;AC-2 COUNTER OF DIGITS TO RIGHT OF DECIMAL POINT PLUS ONE.
00700 ;AC-3 MINUS SIGN FLAG.
00800 SETZ↔SETZB 2,3
00900 L1: INCHWL 1
01000 CAIE 1,"-"↔GO .+3↔SETCMM 3↔GO L1
01100 CAIE 1,"."↔GO .+3↔JUMPN 2,L2↔AOJA 2,L1
01200 CAIL 1,"0"↔CAILE 1,"9"↔GO L2
01300 JUMPN 2,[CAILE 2,4↔GO L1↔AOJA 2,.+1]
01400 ANDI 1,17↔IMULI =10↔ADD 1↔GO L1
01500 L2: FLOAT↔SOSLE 2↔FDVR[1.0↔10.0↔100.0↔1000.0↔10000.0](2)
01600 SKIPE 3↔MOVNS↔POP0J
01700 BEND REALIN; 16 DECEMBER 1972 ------------------------------------
01800 END